home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclxcompat.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-20  |  9.6 KB  |  312 lines
  1. /*
  2.  * This is a hack to retain partial compatibility with shared library
  3.  * version 3.0 which was based on tclX7.1a-B5.
  4.  */
  5.  
  6. /*
  7.  * tclXshell.c --
  8.  *
  9.  * Support code for the Extended Tcl shell.
  10.  *-----------------------------------------------------------------------------
  11.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  12.  *
  13.  * Permission to use, copy, modify, and distribute this software and its
  14.  * documentation for any purpose and without fee is hereby granted, provided
  15.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  16.  * Mark Diekhans make no representations about the suitability of this
  17.  * software for any purpose.  It is provided "as is" without express or
  18.  * implied warranty.
  19.  *-----------------------------------------------------------------------------
  20.  * $Id: tclXshell.c,v 3.0 1993/11/19 06:58:30 markd Rel $
  21.  *-----------------------------------------------------------------------------
  22.  */
  23.  
  24. #include "tclExtdInt.h"
  25.  
  26. int __TclX_AppInit(Tcl_Interp *interp);
  27.  
  28. extern char *optarg;
  29. extern int   optind, opterr;
  30.  
  31.  
  32. /*
  33.  * Name of a user-specific startup script to source if the application is
  34.  * being run interactively (e.g. "~/.tclrc").  Set by Tcl_AppInit.
  35.  *  NULL means don't source anything ever.
  36.  */
  37. extern char *tcl_RcFileName;
  38.  
  39. static char  exitCmd [] = "exit";
  40. static char *TCLXENV = "TCLXENV";
  41.  
  42.  
  43. /*
  44.  * Prototypes of internal functions.
  45.  */
  46. static void
  47. ParseCmdLine _ANSI_ARGS_((Tcl_Interp   *interp,
  48.                           int           argc,
  49.                           char        **argv));
  50.  
  51. /*
  52.  *-----------------------------------------------------------------------------
  53.  *
  54.  * ParseCmdLine --
  55.  *
  56.  *   Parse the command line for the TclX shell ("tcl") and similar programs.
  57.  * This sets Tcl variables and returns, no other action is taken at this
  58.  * time.  The following Tcl variables are initialized by this routine:
  59.  *
  60.  *   o argv0 -  The name of the Tcl program specified on the command line or
  61.  *     the name that the Tcl shell was invoked under if no program was
  62.  *     specified.
  63.  *   o argc - Contains a count of the number of argv arguments (0 if none).
  64.  *   o argv- A list containing the arguments passed in from the command line,
  65.  *     excluding arguments used by the Tcl shell.  The first element is the
  66.  *     first passed argument, not the program name.
  67.  *   o tcl_interactive - Set to 1 if Tcl shell is invoked interactively, or
  68.  *     0 if the Tcl shell is directly executing a script.
  69.  *   o TCLXENV(evalCmd) - Command to eval, as specified by the -c flag.
  70.  *   o TCLXENV(evalFile) - File specified on the command to evaluate rather
  71.  *     than go interactive.
  72.  *   o TCLXENV(quick) - If defined, the -q for quick startup flag was
  73.  *     specified.
  74.  *   o TCLXENV(noDump) - If defined, the -n for no stack dump on error flag
  75.  *     was specified.
  76.  *
  77.  * This function should be called before any application or package specific
  78.  * initialization.  It aborts if an error occurs processing the command line.
  79.  *
  80.  * Parameters:
  81.  *   o interp - A pointer to the interpreter.
  82.  *   o argc, argv - Arguments passed to main for the command line.
  83.  * Notes:
  84.  *   The variables tclAppName, tclAppLongName, tclAppVersion must be set
  85.  * before calling thus routine if special values are desired.
  86.  *-----------------------------------------------------------------------------
  87.  */
  88. static void
  89. ParseCmdLine (interp, argc, argv)
  90.     Tcl_Interp   *interp;
  91.     int           argc;
  92.     char        **argv;
  93. {
  94.     char  *scanPtr, *tclArgv, *errorStack, numBuf [32];
  95.     int    option;
  96.     char  *evalFile = NULL;
  97.     char  *evalCmd  = NULL;
  98.     int    quick    = FALSE;
  99.     int    noDump   = FALSE;
  100.  
  101.     /*
  102.      * Scan arguments looking for flags to process here rather than to pass
  103.      * on to the scripts.  The '-c' or '-f' must also be the last option to
  104.      * allow for script arguments starting with `-'.
  105.      */
  106.     while ((option = getopt (argc, argv, "qc:f:un")) != -1) {
  107.         switch (option) {
  108.           case 'q':
  109.             if (quick)
  110.                 goto usageError;
  111.             quick = TRUE;
  112.             break;
  113.           case 'n':
  114.             if (noDump)
  115.                 goto usageError;
  116.             noDump = TRUE;
  117.             break;
  118.           case 'c':
  119.             evalCmd = optarg;
  120.             goto exitParse;
  121.           case 'f':
  122.             evalFile = optarg;
  123.             goto exitParse;
  124.           case 'u':
  125.           default:
  126.             goto usageError;
  127.         }
  128.     }
  129.   exitParse:
  130.   
  131.     /*
  132.      * If neither `-c' nor `-f' were specified and at least one parameter
  133.      * is supplied, then if is the file to execute.  The rest of the arguments
  134.      * are passed to the script.  Check for '--' as the last option, this also
  135.      * is a terminator for the file to execute.
  136.      */
  137.     if ((evalCmd == NULL) && (evalFile == NULL) && (optind != argc) &&
  138.         !STREQU (argv [optind-1], "--")) {
  139.         evalFile = argv [optind];
  140.         optind++;
  141.     }
  142.  
  143.     /*
  144.      * Set the Tcl argv0, argv & argc variables.
  145.      */
  146.     if (Tcl_SetVar (interp, "argv0",
  147.                     (evalFile != NULL) ? evalFile : argv [0],
  148.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  149.         goto tclError;
  150.  
  151.     tclArgv = Tcl_Merge (argc - optind,  &argv [optind]);
  152.     if (Tcl_SetVar (interp, "argv", tclArgv,
  153.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  154.         goto tclError;
  155.     ckfree (tclArgv);
  156.  
  157.     sprintf (numBuf, "%d", argc - optind);
  158.     if (Tcl_SetVar (interp, "argc", numBuf, 
  159.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  160.         goto tclError;
  161.  
  162.     /*
  163.      * Set the interactive flag, based on what we have parsed.
  164.      */
  165.     if (Tcl_SetVar (interp, "tcl_interactive", 
  166.                     ((evalCmd == NULL) && (evalFile == NULL)) ? "1" : "0",
  167.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  168.         goto tclError;
  169.  
  170.     /*
  171.      * Set elements in the TCLXENV array.
  172.      */
  173.     if (evalCmd != NULL) {
  174.         if (Tcl_SetVar2 (interp, TCLXENV, "evalCmd", evalCmd,
  175.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  176.             goto tclError;
  177.     }
  178.     if (evalFile != NULL) {
  179.         if (Tcl_SetVar2 (interp, TCLXENV, "evalFile", evalFile,
  180.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  181.             goto tclError;
  182.     }
  183.     if (quick) {
  184.         if (Tcl_SetVar2 (interp, TCLXENV, "quick", "1",
  185.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  186.             goto tclError;
  187.     }
  188.     if (noDump) {
  189.         if (Tcl_SetVar2 (interp, TCLXENV, "noDump", "1",
  190.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  191.             goto tclError;
  192.     }
  193.     return;
  194.  
  195.   usageError:
  196.     fprintf (stderr, "usage: %s %s\n", argv [0],
  197.              "?-qun? ?-f? ?script?|?-c command? ?args?");
  198.     exit (1);
  199.  
  200.   tclError:
  201.     TclX_ErrorExit (interp, 255);
  202. }
  203.  
  204.  
  205. /*
  206.  *-----------------------------------------------------------------------------
  207.  *
  208.  * TclX_Shell --
  209.  *
  210.  *   This function runs the TclX shell, including parsing the command line and
  211.  * calling the Tcl_AppInit function at the approriate place.  It either enters
  212.  * interactive command mode or evaulates a script or command from the command
  213.  * line.
  214.  *
  215.  * Parameters:
  216.  *   o argc, argv - Arguments passed to main for the command line.
  217.  * Notes:
  218.  *   Does not return.
  219.  *-----------------------------------------------------------------------------
  220.  */
  221. void
  222. __TclX_Main (argc, argv)
  223.     int    argc;
  224.     char **argv;
  225. {
  226.     Tcl_Interp *interp;
  227.     char       *evalStr;
  228.  
  229.     /* 
  230.      * Create a basic Tcl interpreter.
  231.      */
  232.     interp = Tcl_CreateInterp();
  233.  
  234.     /*
  235.      * Do command line parsing.  This does not return on an error.  Information
  236.      * for command line is saved in Tcl variables.
  237.      */
  238.     ParseCmdLine (interp, argc, argv);
  239.  
  240.     /*
  241.      * Initialized all packages and application specific commands.  This
  242.      * includes Extended Tcl initialization.
  243.      */
  244.     if (__TclX_AppInit (interp) == TCL_ERROR)
  245.         goto errorExit;
  246.  
  247.     /*
  248.      * Evaluate either a command or file if it was specified on the command
  249.      * line.
  250.      */
  251.     evalStr = Tcl_GetVar2 (interp, TCLXENV, "evalCmd", TCL_GLOBAL_ONLY);
  252.     if (evalStr != NULL) {
  253.         if (Tcl_Eval (interp, evalStr) == TCL_ERROR)
  254.             goto errorExit;
  255.         goto okExit;
  256.     }
  257.  
  258.     evalStr = Tcl_GetVar2 (interp, TCLXENV, "evalFile", TCL_GLOBAL_ONLY);
  259.     if (evalStr != NULL) {
  260.         if (Tcl_EvalFile (interp, evalStr) == TCL_ERROR)
  261.             goto errorExit;
  262.         goto okExit;
  263.     }
  264.     
  265.     /*
  266.      * Otherwise, enter an interactive command loop.  Setup SIGINT handling
  267.      * so user may interrupt with out killing program.
  268.      */
  269.     TclX_EvalRCFile (interp);
  270.     Tcl_SetupSigInt ();
  271.  
  272.     if (Tcl_CommandLoop (interp, isatty (0)) == TCL_ERROR)
  273.         goto errorExit;
  274.  
  275.   okExit:
  276.     /* 
  277.      * Delete the interpreter if memory debugging or explictly requested.
  278.      * Useful for finding memory leaks.
  279.      */
  280.  
  281. #if defined(TCL_MEM_DEBUG) || defined(TCL_DELETE_INTERP)
  282.     Tcl_DeleteInterp(interp);
  283.  
  284. #ifdef TCL_SHELL_MEM_LEAK
  285.     printf (" >>> Dumping active memory list to mem.lst <<<\n");
  286.     if (Tcl_DumpActiveMemory ("mem.lst") != TCL_OK)
  287.         panic ("error accessing `mem.lst': %s", strerror (errno));
  288. #endif
  289.     exit(0);
  290. #endif
  291.  
  292.     /*
  293.      * If no memory debugging, exit though the exit command to clean up.
  294.      */
  295.     Tcl_GlobalEval (interp, exitCmd);
  296.  
  297.     exit (0);  /* Just in case */
  298.  
  299.   errorExit:
  300.     TclX_ErrorExit (interp, 255);
  301. }
  302.  
  303. static void unsupported(char *func)
  304. {
  305.     fprintf(stderr, "libtclx: %s is no longer supported\n");
  306.     exit(128);
  307. }
  308.  
  309. int __TclX_AppInit(Tcl_Interp *interp) { return TCL_ERROR; }
  310. void __TclX_RunShell(void) { unsupported("TclX_RunShell"); }
  311. void __TclX_ParseCmdLine(void) { unsupported("TclX_ParseCmdLine"); }
  312.